home *** CD-ROM | disk | FTP | other *** search
/ Acorn RISC PD-CD 1 / Acorn RISC PD-CD 1.iso / languages / perl / usub / cmus next >
Encoding:
Text File  |  1990-11-08  |  2.4 KB  |  130 lines
  1. #!/usr/bin/perl
  2.  
  3. while (<>) {
  4.     if (s/^CASE\s+//) {
  5.     @fields = split;
  6.     $funcname = pop(@fields);
  7.     $rettype = "@fields";
  8.     @modes = ();
  9.     @types = ();
  10.     @names = ();
  11.     @outies = ();
  12.     @callnames = ();
  13.     $pre = "\n";
  14.     $post = '';
  15.  
  16.     while (<>) {
  17.         last unless /^[IO]+\s/;
  18.         @fields = split(' ');
  19.         push(@modes, shift(@fields));
  20.         push(@names, pop(@fields));
  21.         push(@types, "@fields");
  22.     }
  23.     while (s/^<\s//) {
  24.         $pre .= "\t    $_";
  25.         $_ = <>;
  26.     }
  27.     while (s/^>\s//) {
  28.         $post .= "\t    $_";
  29.         $_ = <>;
  30.     }
  31.     $items = @names;
  32.     $namelist = '$' . join(', $', @names);
  33.     $namelist = '' if $namelist eq '$';
  34.     print <<EOF;
  35.     case US_$funcname:
  36.     if (items != $items)
  37.         fatal("Usage: &$funcname($namelist)");
  38.     else {
  39. EOF
  40.     if ($rettype eq 'void') {
  41.         print <<EOF;
  42.         int retval = 1;
  43. EOF
  44.     }
  45.     else {
  46.         print <<EOF;
  47.         $rettype retval;
  48. EOF
  49.     }
  50.     foreach $i (1..@names) {
  51.         $mode = $modes[$i-1];
  52.         $type = $types[$i-1];
  53.         $name = $names[$i-1];
  54.         if ($type =~ /^[A-Z]+\*$/) {
  55.         $cast = "*($type*)";
  56.         }
  57.         else {
  58.         $cast = "($type)";
  59.         }
  60.         $what = ($type =~ /^(struct\s+\w+|char|[A-Z]+)\s*\*$/ ? "get" : "gnum");
  61.         $type .= "\t" if length($type) < 4;
  62.         $cast .= "\t" if length($cast) < 8;
  63.         $x = "\t" x (length($name) < 6);
  64.         if ($mode =~ /O/) {
  65.         if ($what eq 'gnum') {
  66.             push(@outies, "\t    str_numset(st[$i], (double) $name);\n");
  67.         }
  68.         else {
  69.             push(@outies, "\t    str_set(st[$i], (char*) $name);\n");
  70.         }
  71.         push(@callnames, "&$name");
  72.         }
  73.         else {
  74.         push(@callnames, $name);
  75.         }
  76.         if ($mode =~ /I/) {
  77.         print <<EOF;
  78.         $type    $name =$x    $cast    str_$what(st[$i]);
  79. EOF
  80.         }
  81.         else {
  82.         print <<EOF;
  83.         $type    $name;
  84. EOF
  85.         }
  86.     }
  87.     $callnames = join(', ', @callnames);
  88.     $outies = join("\n",@outies);
  89.     if ($rettype eq 'void') {
  90.         print <<EOF;
  91. $pre        (void)$funcname($callnames);
  92. EOF
  93.     }
  94.     else {
  95.         print <<EOF;
  96. $pre        retval = $funcname($callnames);
  97. EOF
  98.     }
  99.     if ($rettype =~ /^(struct\s+\w+|char)\s*\*$/) {
  100.         print <<EOF;
  101.         str_set(st[0], (char*) retval);
  102. EOF
  103.     }
  104.     elsif ($rettype =~ /^[A-Z]+\s*\*$/) {
  105.         print <<EOF;
  106.         str_nset(st[0], (char*) &retval, sizeof retval);
  107. EOF
  108.     }
  109.     else {
  110.         print <<EOF;
  111.         str_numset(st[0], (double) retval);
  112. EOF
  113.     }
  114.     print $outies if $outies;
  115.     print $post if $post;
  116.     if (/^END/) {
  117.         print "\t}\n\treturn sp;\n";
  118.     }
  119.     else {
  120.         redo;
  121.     }
  122.     }
  123.     elsif (/^END/) {
  124.     print "\t}\n\treturn sp;\n";
  125.     }
  126.     else {
  127.     print;
  128.     }
  129. }
  130.